Personal Computer World 2006 May/PCWMAY06.iso/Software/Trial/ConceptDraw NetDiagrammer/data1.cab/Samples__Basic/Solutions/OrgChart/loadTXTFunctions.cdb

Text File | 2006-02-08 | 7KB | 161 lines

'Функция BuildOrgTreeFromTXT зачитывает данные о структуре организации из текстовой базы данных
'и заполняет массивы, в которых хранятся данные о сотруднике и его положении в структуре.
Function BuildOrgTreeFromTXT(ByRef strTextFileName As String) As Boolean
On Error GoTo ErrHandle

Dim intFileNumber As Integer        'Идентификатор обрабатываемого XML-файла
Dim strPersonData As String        'Строка, содержащая одну строку из текстового файла. То же, что одна запись текстовой базы данных с данными одного сотрудника
Dim intFieldsCounter As Integer    'Номер обрабатывающегося поля записи
Dim intSeparatorPos As Integer    'Позиция разделителя полей базы данных
Dim strFiels As String            'Содержимое одного поля записи базы
Dim fNoError As Boolean            'Флаг, показывающий, что при обработке данных файла нет ошибок
Dim strCharSeparator As String    'Разделитель полей базы данных
Dim fWasFoundChiefID As Boolean    'Флаг, показывающий, что в записи присутствует ID руководителя сотрудника
Dim fWasFoundID As Boolean        'Флаг, показывающий, что в записи присутствует ID сотрудника

Dim i As Integer
Dim j As Integer

strCharSeparator = constrCharSeparator

fNoError = True

'Открытие текстового файла для чтения данных
intFileNumber = FreeFile()
Open strTextFileName For Input As #intFileNumber
i=-1
'Первое чтение файла. Определение количества непустых строк в файле.
'Каждая непустая строка считается записью с данными одного сотрудника.
Do While Not EOF(intFileNumber)
    Line Input #intFileNumber, strPersonData
    If Trim$(strPersonData)<>"" Then
        i=i+1
    End If
Loop
iUBound = i + 1
'Если в базе нет ни одного сотрудника, выдать сообщение об ошибке.
If iUBound = 0 Then
    MsgBox("V baze dannih o sotrudnikah ne najdeno ni odnoj zapisi.")
    BuildOrgTreeFromTXT = False
    Exit Function
End If

'Определение размерности массивов в соответствии с количеством сотрудников в базе данных.
ReDim asID(iUBound) As String
ReDim asChiefID(iUBound) As String
ReDim asName(iUBound) As String
ReDim asPost(iUBound) As String
ReDim asEMail(iUBound) As String
ReDim aiLevel(iUBound) As Integer
ReDim adBranchWidth(iUBound) As Double
ReDim adBranchHeight(iUBound) As Double
ReDim abNewPage(iUBound) As Boolean
ReDim asSubordCount(iUBound) As Integer
ReDim asSubordinates(iUBound,iUBound) As Integer
'Инициализация данных для условного нулевого сотрудника.
strOrgName = ""
asID(0)=""
asChiefID(0)=""
asName(0)=""
asPost(0)=""
asEMail(0)=""
aiLevel(0)=0
adBranchWidth(0)=0
adBranchHeight(0)=0
abNewPage(0)=False
asSubordCount(0)=0

'Теперь просматриваем файл повторно с заполнением подготовленных для работы массивов.
Seek #intFileNumber, 1
i=0
'Пока не достигнут конец файла и не произошла ошибка, построчно зачитываем по одной записи с данными сотрудника
Do While (Not EOF(intFileNumber)) And fNoError
    Line Input #intFileNumber, strPersonData
    strPersonData = Trim$(strPersonData)
    If strPersonData <> "" Then
'Если зачитаны данные о новом сотруднике, заполняем элементы массивов с индексом, соответствующим данному сотруднику
        i=i+1
        intFieldsCounter = 1
        Do
'Обрабатываем поля записи до тех пор, пока не достигнем конца строки. Данные из полей помещаем в массивы.
            intSeparatorPos = InStr(strPersonData, strCharSeparator)
            If intSeparatorPos > 0 Then
            strFiels = Trim(Left(strPersonData, intSeparatorPos - 1))
                strPersonData = Right(strPersonData, Len(strPersonData) - intSeparatorPos)
            Else
                strFiels = Trim(strPersonData)
            End If
            Select Case intFieldsCounter
            Case conintIDPos
                asID(i) = strFiels
            Case conintNamePos
                asName(i) = strFiels
            Case conintChiefIDPos
                If asChiefID(i) = "0" Then
                    strFiels = ""
                End If
                asChiefID(i) = strFiels
            Case conintPostPos
                asPost(i) = strFiels
            Case conintEMailPos
                asEMail(i) = strFiels
            Case Else
            End Select
            intFieldsCounter = intFieldsCounter + 1
        Loop While intSeparatorPos > 0
        'Проверка возможных ошибочных ситуаций
        If asID(i) = "" Then
            MsgBox("Pri obrabotke spiska voznikla oshibochka. Identifikatori zapisej ne dolzhni bit' pustimi strokami ili 0. Identifikator zapisi " & asName(i) & " okazalsja raven """ & asID(i) & """.")
            fNoError = False
        ElseIf asID(i) = asChiefID(i) Then
            MsgBox("Pri obrabotke spiska voznikla oshibochka. Identifikator rukovoditelja sotrudnika " & asName(i) & " okazalsja raven identifikatoru samogo sotrudnika.")
            fNoError = False
        Else
            j=1
            fWasFoundID = False
            Do While (Not fWasFoundID) And j<i
                If asID(i) = asID(j) Then
                    fWasFoundID = True
                    MsgBox("Pri obrabotke spiska voznikla oshibochka. Identifikator sotrudnika " & asName(i) & " okazalsja raven identifikatoru sotrudnika " & asName(j) & ".")
                    fNoError = False
                End If
                j=j+1
            Loop
        End If
    End If
Loop

Close #intFileNumber

'Если при зачитке данных не произошло ошибок,...
If fNoError Then
    '...то для каждого сотрудника...
    For i=1 To iUBound
        j=0
        fWasFoundChiefID = False
        '...просматриваем список его колег.
        Do While (Not fWasFoundChiefID) And j<=iUBound
            'Если ID коллеги совпадает с ID руководителя сотрудника,...
            If asChiefID(i) = asID(j) Then
                fWasFoundChiefID = True
                '...то к списку подчиненных коллеги добавляется индекс сотрудника.
                asSubordinates(j,asSubordCount(j))=i
                asSubordCount(j)=asSubordCount(j)+1
            End If
            j=j+1
        Loop
    Next
    BuildOrgTreeFromTXT = True
Else
    BuildOrgTreeFromTXT = False
End If

Exit Function

ErrHandle:
    MsgBox ("In performing the macros, an error has occured.", cdbExclamation)
    BuildOrgTreeFromTXT = False
    Exit Function
End Function